home *** CD-ROM | disk | FTP | other *** search
/ Experimental BBS Explossion 3 / Experimental BBS Explossion III.iso / pascal / pkpas1.zip / PKDEMO2.PAS < prev    next >
Pascal/Delphi Source File  |  1993-10-17  |  7KB  |  248 lines
  1. Program PkDemo2;
  2. {$D-,S-,R-,B-,I+}
  3.  
  4.  (***************************************************************
  5.  
  6.   Second demo of PKware unit, showing use of the FileStats record.
  7.  
  8.   Copyright Terry Sansom Oct, 1993
  9.  
  10.   ***************************************************************)
  11.  
  12. USES DOS,CRT, PKWareU;
  13.  
  14. CONST
  15.      HexDigits : ARRAY[0..15] OF Char = '0123456789ABCDEF';
  16.  
  17. TYPE
  18.      D2 = String[2];
  19.  
  20. VAR
  21.     EntryCount: Byte;
  22.     FileName  : String;
  23.     FileOpen  : Boolean;        { Flag set if file is open }
  24.     CFH       : CentralFileHeaderType;
  25.     FS        : FileStats;
  26.     Error     : Word;
  27.  
  28. { ********* The folowing are used in formating output ************* }
  29.  
  30.       Function HexNum(L:LongInt):String;
  31.       { Convert a longint type to HEX string }
  32.       VAR T : String[8];
  33.         BEGIN
  34.           T[0] := #8;
  35.           T[1] := HexDigits[L SHR 28];
  36.           T[2] := HexDigits[(L SHR 24) AND $F];
  37.           T[3] := HexDigits[(L SHR 20) AND $F];
  38.           T[4] := HexDigits[(L SHR 16) AND $F];
  39.           T[5] := HexDigits[(L SHR 12) AND $F];
  40.           T[6] := HexDigits[(L SHR 8) AND $F];
  41.           T[7] := HexDigits[(L SHR 4) AND $F];
  42.           T[8] := HexDigits[L AND $F];
  43.           HexNum := T;
  44.       end;
  45.  
  46.          Function StrNum(I:Word):D2;
  47.          { add leading 0 to number }
  48.          var S:D2;
  49.          begin
  50.            Str(I,S);
  51.            IF I < 10 then
  52.               Insert('0',S,1);
  53.            StrNum := S;
  54.          end;
  55.  
  56.       Function PadStr(S:String;Size:Byte):String;
  57.       { Pad a string to the right }
  58.       VAR Temp:String;
  59.           Len: Byte;
  60.       begin
  61.           Fillchar(Temp[1],Size,' ');
  62.           Temp[0] := chr(Size);
  63.           Len := length(S);
  64.           If Len <= Size then
  65.              Move(S[1],Temp[succ(Size - Len)],Len)
  66.           else
  67.              Move(S[1],Temp[1],size);
  68.          PadStr := Temp;
  69.       end;
  70.  
  71.       Function PadNum(I:LongInt; Size:Byte): String;
  72.       { Pad a number to the Right }
  73.       VAR ST:String;
  74.       begin
  75.         Str(I,ST);
  76.         PadNum := PadStr(St,Size);
  77.       end;
  78.  
  79.  
  80.      Function AttrStr(Attr:LongInt):String;
  81.      VAR S: String[4];
  82.       begin
  83.        S := '';
  84.        IF (Attr = Archive) then
  85.           S := 'w';
  86.        IF (Attr = Hidden) then
  87.           S := S+'h';
  88.        IF (Attr = ReadOnly ) then
  89.           S := S + 'r';
  90.        IF (Attr = SysFile ) then
  91.           S := S +'s';
  92.        AttrStr := S;
  93.       end;
  94.  
  95.       Function TimeStr(D:LongInt):String;
  96.       VAR DT: DateTime;
  97.       begin
  98.        UNpackTime(D,DT);
  99.        With DT do
  100.        begin
  101.         TimeStr :=  StrNum(Month)+'-'+StrNum(Day)+'-'+StrNum(Year-1900)+' '+
  102.                     StrNum(Hour)+':'+StrNum(Min);
  103.        end;
  104.       end;
  105.  
  106.  { Shows reason for teminating }
  107.  
  108.    Procedure ShowError(I:Word);
  109.    begin
  110.      Writeln;
  111.      Case I of
  112.       0: Writeln('End of demo.. no errors');
  113.       1:Writeln('Signature indicates there is an error.');
  114.       2:Writeln('Block read error.');
  115.       3:Writeln('Sorry file not found...');
  116.       4: Writeln('User request: program termintaion..');
  117.       Else Writeln('IO error.');
  118.      end;
  119.     IF FileOpen then
  120.       Close(ZipFile);
  121.     Halt(I);
  122.    end;
  123.  
  124.     Procedure Anykey;
  125.     VAR CH:Char;
  126.     begin
  127.      HighVideo;
  128.      Writeln('Press any key to continue Esc to stop.');
  129.      NormVideo;
  130.      Ch := Readkey;
  131.      IF Ch = #27 then ShowError(4);
  132.     end;
  133.  
  134. Procedure Welcome;
  135. begin
  136.   Clrscr;
  137.   Writeln('---------------------------------------------------------------');
  138.   HighVideo;
  139.   Writeln('             PKDemo Demo for PKWareU version 1.0 ');
  140.   LowVideo;
  141.   Writeln;
  142.   Writeln(' A simple demonstration for reading PKzipped files for Turbo');
  143.   Writeln(' Pascal version 5.x.  See README.TXT for details.');
  144.   Writeln;
  145.   Writeln(' 1:  Enter the Zipped file you wish to examine.');
  146.   Writeln;
  147.   Writeln(' 2:  If the file is found, a short summary of the Zip archive will');
  148.   Writeln('     be displayed');
  149.   Writeln;
  150.   Writeln(' 3:  Each keystroke will show details of each file in the');
  151.   Writeln('     archive.');
  152.   Writeln;
  153.   Writeln('---------------------------------------------------------------');
  154.   AnyKey;
  155. end;
  156.  
  157.   Procedure GetZipFile;
  158.   VAR
  159.       Error: Word;
  160.    begin
  161.      Filename := '';
  162.      Write(' Enter the zipped file: ');
  163.      Readln(Filename);
  164.      If FileName = '' then
  165.        ShowError(3);
  166.      Assign(ZipFile, Filename);
  167.      {$I-}
  168.        Reset(ZipFile);
  169.        Error := IOResult;
  170.      {$I+}
  171.      If Error <> 0 then
  172.        ShowError(3);
  173.      FileOpen:= True;
  174.    end;
  175.  
  176. Procedure Header;
  177. begin
  178.   HighVideo;
  179.    Writeln(' Filename    Method      Orig. Size Comp. Size  Date     Time   CRC-32     Attr');
  180.    Writeln('------------ ----------- ---------- ----------  -------- -----  ---------  ----');
  181.    NormVideo;
  182. end;
  183.  
  184. Procedure ShowFileStat;
  185. begin
  186.  CFH_to_FileStat(CFH, FS);
  187.  With FS do
  188.  begin
  189.    Write(Name);
  190.    Gotoxy(14,WhereY);
  191.    Write(CompMethod[Method]);
  192.    Gotoxy(26,WhereY);
  193.    Writeln(PadNum(OSize,10),' ',PadNum(CSize,10),' ',TimeStr(Date):15,' ',
  194.            HexNum(Crc):10,' ',AttrStr(Attr):5);
  195.  end;
  196. end;
  197.  
  198. Procedure SHowZipStats;
  199. begin
  200.   Clrscr;
  201.   With ZipStats Do
  202.     begin
  203.       Writeln;
  204.  
  205.       Writeln('    ---- Zip Stat`s before reading central directory ---');
  206.       Write('             For file: ');
  207.       HighVideo; Writeln(FileName); NormVideo;
  208.       Writeln;
  209.       Writeln('      End Signature           : ', HexNum(EndSig));
  210.       Writeln('      Disk Number             : ', DiskNum);
  211.       Writeln('      Disk num. with start    : ', DiskwStart);
  212.       Writeln('      Number of entries       : ', NumEntries);
  213.       Writeln('      Total number of entries : ', TNumEntries);
  214.       Writeln('      Size of central dir.    : ', SizeCentral);
  215.       Writeln('      Offset of central       : ', OffsetDirRelDiskNum);
  216.       Writeln('      Size of comment         : ', CommentLen);
  217.       Writeln;
  218.    end;
  219.    Writeln('    ---------------------------------------------------');
  220.    Writeln;
  221. end;
  222.  
  223. begin
  224.   FileOpen := False;
  225.   Welcome;
  226.   GetZipFile;
  227.   Error := GetZipStats;
  228.   If Error = 0 then
  229.    begin
  230.      ShowZipStats;
  231.      AnyKey;
  232.      Clrscr;
  233.      Header;
  234.      For EntryCount := 1 to ZipStats.TNumEntries do
  235.        begin
  236.          Error := ReadFileHeader(Cfh);
  237.          If Error = 0 then
  238.            begin
  239.              ShowFileStat;
  240.           { AnyKey;}  { Remove comments if you want pauses between }
  241.            end
  242.          Else ShowError(Error);
  243.        end; { for }
  244.      Writeln('-------------------------------------------------------------------------------');
  245.     end { if }
  246.   Else ShowError(Error);
  247.   ShowError(0); { close file and exit }
  248. end.